home *** CD-ROM | disk | FTP | other *** search
/ Atari Forever 4 / Atari Forever 4.zip / Atari Forever 4.iso / FALCON / BIGDISKS / BIG_05 / TRICKFIL.M / TRICKFLM.LST < prev    next >
File List  |  1998-03-14  |  30KB  |  962 lines
  1. ' *****************************************************************************
  2. '
  3. '   Programm zum Herstellen von kleinen Zeichentrickfilmen
  4. '
  5. '   von Heiko Müller, Mozartstraße 17, 2905 Edewecht
  6. '
  7. datum$="18.06.1988"           ! letztes Bearbeitungsdatum
  8. '
  9. ' *****************************************************************************
  10. '
  11. ON ERROR GOSUB fehler     ! falls es den Ordner "FILME" schon gibt, entsteht
  12. '                         ! in der nächsten Zeile ein Fehler:
  13. MKDIR "FILME"             ! diese ersten Zeilen vor dem Compilieren löschen
  14. GOSUB speicher_einrichten
  15. GOSUB ueberschrift
  16. GOSUB titelbild
  17. '
  18. ' #############################################################################
  19. '
  20. DO                                              ! Hauptprogrammschleife
  21.   '
  22.   i$=INKEY$                                     ! Tastaturabfrage
  23.   IF i$<>""
  24.     l=LEN(i$)
  25.     a=ASC(RIGHT$(i$))
  26.     GOSUB wat_nu_taste                          ! für Tastaturauswertung
  27.   ENDIF
  28.   '
  29.   MOUSE x%,y%,k%
  30.   IF k%
  31.     IF (x%>270 AND x%<520) AND y%>200 AND y%<350 AND NOT block!
  32.       GET 271,201,519,349,undo$                 ! Bild merken für Undo-Funktion
  33.       GOSUB freihand                            ! Freihand als Grundfunktion
  34.     ELSE
  35.       GOSUB wat_nu                              ! für Mausaktionenauswertung
  36.     ENDIF
  37.   ENDIF
  38. LOOP
  39. '
  40. ' #############################################################################
  41. '
  42. PROCEDURE fehler           ! läuft nicht im compilierten Programm!
  43.   IF ERR=-36               ! wenn der einzurichtende Ordner "FILME" schon
  44.     RESUME NEXT            ! besteht, soll in der Zeile hinter dem Befehl
  45.   ENDIF                    ! "MKDIR" weitergemacht werden.
  46. RETURN
  47. '
  48. PROCEDURE wat_nu                    ! hier werden die Mausaktionen ausgewertet
  49.   '
  50.   REPEAT                            ! erst dann weitermachen, wenn Maustaste
  51.   UNTIL MOUSEK=0                    ! losgelassen wird
  52.   '
  53.   IF y%>110
  54.     GET 271,201,519,349,undo$       ! Bild merken für Undo-Funktion
  55.   ENDIF
  56.   '
  57.   IF y%<50 AND NOT block!           ! große Schrift oben angeklickt
  58.     GOSUB ueberschrift
  59.     GOSUB reparatur
  60.   ENDIF
  61.   '
  62.   IF x%>20 AND x%<620 AND y%>50 AND y%<170   ! 12 große Kästen angeklickt
  63.     z=INT((x%-20)/100)+1+INT((y%-50)/60)*6
  64.     IF NOT block!
  65.       ON z GOSUB spei,lad,abspi,must_wa,lin_wa,fig_fuell,fuell,block,kreis,ellipse,gerade,kasten
  66.     ELSE
  67.       IF z=8
  68.         GOSUB block
  69.       ENDIF
  70.     ENDIF
  71.     '
  72.   ENDIF
  73.   '
  74.   IF x%>20 AND y%>360 AND x%<130 AND y%<380     ! Programmende-Kasten
  75.     GOSUB ende
  76.   ENDIF
  77.   '
  78.   IF x%>270 AND x%<362 AND y%>360 AND y%<380    ! Kästen unter rechtem Bild
  79.     z=INT((x%-270)/24)+1
  80.     IF NOT block!
  81.       ON z GOSUB hoch,runter,rechts,links
  82.     ELSE
  83.       b=1
  84.       IF k%=2
  85.         b=5
  86.       ENDIF
  87.       DEFFILL 0,2,8
  88.       PBOX a1%,b1%,a2%,b2%
  89.       ON z GOSUB b_hoch,b_runter,b_rechts,b_links
  90.       PUT a1%,b1%,block$
  91.       GET 271,201,519,349,bild$(bild%)
  92.       '
  93.       IF a1%<270 OR b1%<200 OR a2%>520 OR b2%>350 ! falls Umgebung durch Block
  94.         IF a1%<270                                ! überdeckt ist
  95.           a1%=270
  96.         ENDIF
  97.         IF b1%<200
  98.           b1%=200
  99.         ENDIF
  100.         IF a2%>520
  101.           a2%=520
  102.         ENDIF
  103.         IF b2%>350
  104.           b2%=350
  105.         ENDIF
  106.         GOSUB reparatur
  107.         GET a1%,b1%,a2%,b2%,block$
  108.         GOSUB kasten_schwarz(8)
  109.       ENDIF
  110.       '
  111.       PAUSE 5
  112.     ENDIF
  113.   ENDIF
  114.   '
  115.   IF x%>540 AND x%<620 AND y%>200 AND y%<380      ! Kasten rechts neben Bildern
  116.     z=INT((y%-200)/20)+1
  117.     IF NOT block!
  118.       ON z GOSUB zurueck,vor,merken,einsetzen,loeschen,entfernen,erweitern,alles_weg,zu_bild
  119.       IF z<3
  120.         GET 271,201,519,349,undo$    ! falls vor oder zurück: neues Bild merken
  121.       ENDIF
  122.       IF z>5            ! nach entfernen, erweitern, Film löschen, zu Bild...
  123.         undo$=""        ! kein Undo mehr möglich
  124.       ENDIF
  125.     ELSE
  126.       ON z GOSUB nicht,nicht,b_merken,hier_nicht,b_loeschen,nicht,nicht,nicht,nicht
  127.     ENDIF
  128.   ENDIF
  129.   '
  130.   IF x%>405 AND y%>360 AND x%<460 AND y%<380
  131.     GOSUB kopieren
  132.   ENDIF
  133.   '
  134. RETURN
  135. '
  136. '
  137. PROCEDURE nicht
  138.   OUT 2,7
  139. RETURN
  140. '
  141. PROCEDURE hier_nicht
  142.   ALERT 0,"Das geht erst, wenn die|Blockfunktion wieder|ausgeschaltet ist.",1,"ach so",antw
  143. RETURN
  144. '
  145. PROCEDURE wat_nu_taste
  146.   '
  147.   ' Diese Procedure wird in diesem Programm nur für die Undo-Taste genutzt.
  148.   ' Es ist möglich, hier noch andere Unterprogrammaufrufe zu installieren,
  149.   ' die per Tastendruck ausgelöst werden.
  150.   ' Dazu werden bei Tastendruck die beiden Variablen a und l belegt,
  151.   ' die man sich durch die folgende Programmzeile zur weiteren Bearbeitung
  152.   ' anzeigen lassen kann:
  153.   '
  154.   ' TEXT 20,190," Taste "+i$+" "+STR$(a)+" "+STR$(l)+" "  ! (später löschen)
  155.   '
  156.   IF a=97 AND l=2          ! Wenn die Undo-Taste getippt wurde
  157.     PUT 271,201,undo$
  158.   ENDIF
  159. RETURN
  160. '
  161. PROCEDURE ueberschrift
  162.   CLS
  163.   DEFTEXT 1,16,0,32
  164.   TEXT 10,50,"# Zeichentrickfilmprogramm ##"
  165.   DEFTEXT 1,0,0,4
  166.   TEXT 550,30,"Version "+version$
  167.   TEXT 550,40,"vom"
  168.   TEXT 550,50,datum$
  169.   TEXT 440,380,"Leertaste: weitere Informationen"
  170.   TEXT 440,390,"rechte Maustaste: Hauptprogramm"
  171.   PRINT AT(3,5);
  172.   PRINT "programmiert in GFA-BASIC von Heiko Müller, Mozartstraße 17, 2905 Edewecht"
  173.   PRINT
  174.   PRINT "  Als Grundfunktion ist das Freihand-Malen eingebaut.  Nur das rechte  Bild"
  175.   PRINT "  kann  bearbeitet  werden.  Mit  der rechten Maustaste läßt  sich  in  der"
  176.   PRINT "  eingestellten Strichstärke radieren."
  177.   PRINT "  Mit  den  vier Pfeilfeldern unter dem rechten Bild  wird  der  Bildinhalt"
  178.   PRINT "  verschoben  - mit der linken Maustaste um ein Pixel,  mit der rechten  um"
  179.   PRINT "  fünf."
  180.   PRINT "  Mit  dem Feld rechts daneben wird das linke (das vorhergehende) Bild  auf"
  181.   PRINT "  das bearbeitete Bild kopiert."
  182.   PRINT "  Mit der Funktion >>merken<< wird der momentane Bildinhalt gespeichert zum"
  183.   PRINT "  späteren >>einsetzen<< in ein anderes Bild."
  184.   PRINT "  Mit der Taste 'Undo'  kann man nach Beendigung der meisten Funktionen die"
  185.   PRINT "  letzten Veränderungen rückgängig machen."
  186.   PRINT "  Jedes Bild wird automatisch gespeichert,  wenn man zu einem anderen  Bild"
  187.   PRINT "  vorwärts oder rückwärts geht."
  188.   PRINT "  Aktionen,  bei  denen  das Bild oder Teile des  Bildes  gelöscht  werden,"
  189.   PRINT "  können nur mit der rechten Maustaste ausgelöst werden."
  190.   PRINT
  191.   PRINT "  Zum Speichern muß (!) der Ordner FILME existieren!"
  192.   '
  193.   REPEAT
  194.     i$=INKEY$
  195.   UNTIL MOUSEK=2 OR i$=" "
  196.   IF i$=" "
  197.     GOSUB weitere_infos
  198.   ENDIF
  199.   DEFTEXT 1,0,0,13
  200.   CLS
  201. RETURN
  202. '
  203. PROCEDURE weitere_infos
  204.   CLS
  205.   PAUSE 30
  206.   PRINT AT(3,2);
  207.   PRINT "Dieses  Programm  darf  mitsamt dem Quellcode beliebig  oft  kopiert  und"
  208.   PRINT "  weitergegeben werden.  Ich selbst habe mich auch oft über andere  GfA-PD-"
  209.   PRINT "  Programme gefreut und daraus auch gerne Teile übernommen."
  210.   PRINT
  211.   PRINT "  Da ich wohl Freude am Programmieren habe,  jedoch nicht am Herstellen von"
  212.   PRINT "  Zeichentrickfilmen,  habe ich als Beispiel nur den 'Pferdefilm'  übernom-"
  213.   PRINT "  men,  den  man auf der Original-BASIC-Diskette findet.  Falls jemand  das"
  214.   PRINT "  Programm  so gut findet,  daß er mir auch einen Gefallen tun  möchte,  so"
  215.   PRINT "  kann er mir ja mal eine Diskette mit eigenen Filmen schicken. Auch andere"
  216.   PRINT "  'selbstgestrickte' GfA-BASIC-Programme nehme ich natürlich gerne an."
  217.   PRINT
  218.   PRINT "  Heiko Müller"
  219.   PRINT "  Mozartstraße 17"
  220.   PRINT "  2905 Edewecht"
  221.   DEFTEXT 1,0,0,4
  222.   TEXT 440,380,"Leertaste oder Mausklick"
  223.   REPEAT
  224.     i$=INKEY$
  225.   UNTIL MOUSEK OR i$=" "
  226.   DEFTEXT 1,0,0,13
  227.   CLS
  228. RETURN
  229. '
  230. PROCEDURE freihand                     ! Diese Procedure wird als Grundfunktion
  231.   DEFLINE 1,breite,2,2                 ! immer angesteuert
  232.   COLOR 1
  233.   IF k%>1
  234.     COLOR 0
  235.   ENDIF
  236.   PLOT x%,y%
  237.   IF merk%=bild%
  238.     text$=" Altes Bild "+STR$(bild%)+" gemerkt"
  239.   ENDIF
  240.   WHILE (x%>270 AND x%<520) AND y%>200 AND y%<350 AND MOUSEK>0
  241.     DRAW  TO x%,y%
  242.     MOUSE x%,y%,k%
  243.   WEND
  244.   COLOR 1
  245.   GET 271,201,519,349,bild$(bild%)
  246. RETURN
  247. '
  248. PROCEDURE spei
  249.   GET 271,201,519,349,bild$(bild%)
  250.   GOSUB kasten_schwarz(1)
  251.   frei=INT(DFREE(0)/1024)           ! freien Platz auf der Diskette ermitteln
  252.   groesse=0
  253.   FOR i%=0 TO schluss               ! Filmlänge ermitteln
  254.     groesse=groesse+LEN(bild$(i%))
  255.   NEXT i%
  256.   groesse=INT(groesse/1024+1)
  257.   al$="Filmlänge: "+STR$(groesse)+" KByte |"
  258.   al$=al$+"freier Platz auf der Diskette:|"+SPACE$(11)+STR$(frei)+" KByte"
  259.   ALERT 0,al$,1," aha ",antw
  260.   IF frei<groesse
  261.     ALERT 3,"Nicht genug Platz| auf der Diskette!| |Soll etwas gelöscht werden?",1,"Abbruch|löschen",antw
  262.     IF antw=2
  263.       FILESELECT "A:\FILME\*.*","",name$
  264.       IF LEN(name$)>0
  265.         ALERT 3," Die Datei        | "+name$+"| löschen ?",1,"Nein| Ja ",antw
  266.         IF antw=2
  267.           KILL name$
  268.         ENDIF
  269.       ENDIF
  270.     ENDIF
  271.   ENDIF
  272.   IF frei>groesse
  273.     IF bild$(endbild%)=bild$(0)            ! leeres Bild am Ende löschen
  274.       bild$(endbild%)=""
  275.       DEC endbild%
  276.     ENDIF
  277.     FILESELECT "A:\FILME\*.FLM","",name$
  278.     IF LEN(name$)>0
  279.       PUT 21,201,bild$(0)
  280.       IF INSTR(name$,".")=0             ! falls im Namen kein Punkt vorkommt,
  281.         name$=name$+".FLM"              ! FLM dranhängen
  282.       ENDIF
  283.       OPEN "O",#1,name$
  284.       DEFMOUSE 2
  285.       '
  286.       ' die folgende Routine stammt aus dem Buch "GFA BASIC" von F. Ostrowski,
  287.       ' ebenso wie die dazugehörige Laderoutine in der nächsten Procedure
  288.       '
  289.       FOR i%=0 TO schluss
  290.         PRINT #1,MKI$(LEN(bild$(i%)));bild$(i%);
  291.         IF bild$(i%)<>""
  292.           TEXT 270,195," Bild "+STR$(i%)+"                  "
  293.           PUT 271,201,bild$(i%)
  294.         ENDIF
  295.       NEXT i%
  296.       CLOSE #1
  297.     ENDIF
  298.   ENDIF
  299.   bild%=1
  300.   GOSUB reparatur
  301. RETURN
  302. '
  303. PROCEDURE lad
  304.   GOSUB kasten_schwarz(z)
  305.   FILESELECT "A:\FILME\*.FLM","",name$
  306.   IF EXIST(name$)                           ! Datei existiert?
  307.     OPEN "I",#1,name$
  308.     FOR i%=0 TO schluss
  309.       bild$(i%)=INPUT$(CVI(INPUT$(2,#1)),#1)
  310.       IF bild$(i%)<>""               ! durch Hochzählen der vollen Bilder
  311.         endbild%=i%                  ! Gesamtbildzahl ermitteln
  312.         TEXT 270,195," Bild "+STR$(i%)+"                         "
  313.         PUT 271,201,bild$(i%)        ! geladene Bilder gleich anzeigen
  314.       ENDIF
  315.     NEXT i%
  316.     bild%=1
  317.   ENDIF
  318.   CLOSE #1
  319.   GOSUB reparatur
  320. RETURN
  321. '
  322. PROCEDURE abspi
  323.   GOSUB kasten_schwarz(z)
  324.   IF bild$(endbild%)=bild$(0)            ! leeres Bild am Ende löschen
  325.     bild$(endbild%)=""
  326.     DEC endbild%
  327.   ENDIF
  328.   ALERT 0,"  Film abspielen  | | In welche Richtung? |  ",2,"  ⇨  | ⇨ ⇦ |  ⇦  ",antw
  329.   DEFFILL 1,2,8
  330.   p=0
  331.   PBOX 0,0,639,399
  332.   TEXT 0,395," linke Maustaste: schneller  *  rechts: langsamer  *  beide:  Stop  * Tempo "+STR$(20-p)+"  "
  333.   HIDEM
  334.   REPEAT
  335.     IF antw<3
  336.       FOR i%=1 TO endbild%               ! Vorwärtsvorführung
  337.         PUT 195,100,bild$(i%)
  338.         PAUSE p
  339.         MOUSE x%,y%,k%
  340.         IF k%
  341.           GOSUB tempo
  342.         ENDIF
  343.         EXIT IF MOUSEK>2
  344.       NEXT i%
  345.     ENDIF
  346.     EXMODE 1
  347.     GET 271,201,519,349,bild$(bild%)
  348.     GOSUB reparatur
  349.     undo$=block_undo$
  350.   ENDIF
  351.   IF linksblock!
  352.     GOSUB linksblock
  353.   ENDIF
  354. RETURN
  355. '
  356. PROCEDURE linksblock
  357.   REPEAT
  358.     MOUSE x%,y%,k%
  359.   UNTIL k% AND ((x%>120 AND x%<220 AND y%>110 AND y%<170) OR (x%>405 AND x%<460 AND y%>360 AND y%<380))
  360.   IF (x%>120 AND x%<220 AND y%>110 AND y%<170)
  361.   ENDIF
  362.   IF x%>405 AND y%>360 AND x%<460 AND y%<380
  363.     GET a1%+1,b1%+1,a2%-1,b2%-1,block$
  364.     PUT a1%+251,b1%,block$
  365.   ENDIF
  366.   linksblock!=FALSE
  367.   z=8
  368.   GOSUB block
  369.   REPEAT
  370.   UNTIL MOUSEK=0
  371. RETURN
  372. '
  373. PROCEDURE kreis
  374.   GOSUB kasten_schwarz(9)
  375.   DEFMOUSE 7
  376.   DEFLINE 1,1,0,0
  377.   TEXT 270,195,"Ende der Funktion durch rechte Maustaste    "
  378.   DO
  379.     MOUSE x%,y%,k%
  380.     EXIT IF k%>1
  381.     IF x%>520 AND x%<620 AND y%>50 AND y%<110 AND k%=1
  382.       GOSUB fig_fuell
  383.     ENDIF
  384.     IF k%=1
  385.       IF merk%=bild%
  386.         text$=" Altes Bild "+STR$(bild%)+" gemerkt"
  387.       ENDIF
  388.       DEFLINE 1,1,0,0
  389.       REPEAT
  390.         MOUSE x%,y%,k%
  391.       UNTIL k%=1
  392.       GRAPHMODE 3
  393.       PAUSE 10
  394.       REPEAT
  395.         MOUSE x1%,y1%,k%
  396.         radius=ABS(x1%-x%)
  397.         CIRCLE x%,y%,radius
  398.         PAUSE 2
  399.         CIRCLE x%,y%,radius
  400.       UNTIL k%<>1
  401.       GRAPHMODE 1
  402.       DEFLINE 1,breite,2,2
  403.       DEFFILL 1,muster1,muster2
  404.       IF figurfuellen!
  405.         PCIRCLE x%,y%,ABS(x1%-x%)
  406.       ELSE
  407.         CIRCLE x%,y%,ABS(x1%-x%)
  408.       ENDIF
  409.       PAUSE 5
  410.     ENDIF
  411.   LOOP
  412.   GET 271,201,519,349,bild$(bild%)
  413.   DEFMOUSE 0
  414.   TEXT 270,195,SPACE$(45)
  415.   GOSUB reparatur
  416.   REPEAT
  417.   UNTIL MOUSEK=0
  418. RETURN
  419. '
  420. PROCEDURE ellipse
  421.   GOSUB kasten_schwarz(10)
  422.   DEFMOUSE 7
  423.   TEXT 270,195,"Ende der Funktion durch rechte Maustaste    "
  424.   DO
  425.     MOUSE x%,y%,k%
  426.     EXIT IF k%>1
  427.     IF x%>520 AND x%<620 AND y%>50 AND y%<110 AND k%=1
  428.       GOSUB fig_fuell
  429.     ENDIF
  430.     IF k%=1
  431.       IF merk%=bild%
  432.         text$=" Altes Bild "+STR$(bild%)+" gemerkt"
  433.       ENDIF
  434.       DEFLINE 1,1,0,0
  435.       REPEAT
  436.         MOUSE x%,y%,k%
  437.       UNTIL k%=1
  438.       GRAPHMODE 3
  439.       PAUSE 10
  440.       REPEAT
  441.         MOUSE x1%,y1%,k%
  442.         ELLIPSE x%,y%,ABS(x1%-x%),ABS(y1%-y%)
  443.         PAUSE 2
  444.         ELLIPSE x%,y%,ABS(x1%-x%),ABS(y1%-y%)
  445.       UNTIL k%<>1
  446.       GRAPHMODE 1
  447.       DEFLINE 1,breite,2,2
  448.       DEFFILL 1,muster1,muster2
  449.       IF figurfuellen!
  450.         PELLIPSE x%,y%,ABS(x1%-x%),ABS(y1%-y%)
  451.       ELSE
  452.         ELLIPSE x%,y%,ABS(x1%-x%),ABS(y1%-y%)
  453.       ENDIF
  454.       PAUSE 5
  455.     ENDIF
  456.   LOOP
  457.   GET 271,201,519,349,bild$(bild%)
  458.   DEFMOUSE 0
  459.   TEXT 270,195,SPACE$(45)
  460.   GOSUB reparatur
  461.   REPEAT
  462.   UNTIL MOUSEK=0
  463. RETURN
  464. '
  465. PROCEDURE gerade
  466.   GOSUB kasten_schwarz(11)
  467.   DEFMOUSE 5
  468.   DEFLINE 1,1,0,0
  469.   TEXT 270,195,"Ende der Funktion durch rechte Maustaste    "
  470.   DO
  471.     MOUSE x%,y%,k%
  472.     EXIT IF k%>1
  473.     IF x%>270 AND x%<520 AND y%>200 AND y%<350 AND k%=1
  474.       IF merk%=bild%
  475.         text$=" Altes Bild "+STR$(bild%)+" gemerkt"
  476.       ENDIF
  477.       DEFLINE 1,1,0,0
  478.       GRAPHMODE 3
  479.       PAUSE 10
  480.       REPEAT
  481.         MOUSE x1%,y1%,k%
  482.         IF x1%<270
  483.           x1%=270
  484.         ENDIF
  485.         IF x1%>520
  486.           x1%=520
  487.         ENDIF
  488.         IF y1%>350
  489.           y1%=350
  490.         ENDIF
  491.         IF y1%<200
  492.           y1%=200
  493.         ENDIF
  494.         LINE x%,y%,x1%,y1%
  495.         PAUSE 2
  496.         LINE x%,y%,x1%,y1%
  497.       UNTIL k%<>1
  498.       GRAPHMODE 1
  499.       DEFLINE 1,breite,2,2
  500.       LINE x%,y%,x1%,y1%
  501.       PAUSE 5
  502.     ENDIF
  503.   LOOP
  504.   GET 271,201,519,349,bild$(bild%)
  505.   TEXT 270,195,SPACE$(45)
  506.   GOSUB reparatur
  507.   REPEAT
  508.   UNTIL MOUSEK=0
  509. RETURN
  510. '
  511. '
  512. PROCEDURE kasten
  513.   GOSUB kasten_schwarz(12)
  514.   DEFMOUSE 5
  515.   DEFLINE 1,1,0,0
  516.   TEXT 270,195,"Ende der Funktion durch rechte Maustaste    "
  517.   DO
  518.     MOUSE x%,y%,k%
  519.     EXIT IF k%>1
  520.     IF x%>520 AND x%<620 AND y%>50 AND y%<110 AND k%=1
  521.       GOSUB fig_fuell
  522.     ENDIF
  523.     IF x%>20 AND x%<520 AND y%>200 AND y%<350 AND k%=1
  524.       IF merk%=bild%
  525.         text$=" Altes Bild "+STR$(bild%)+" gemerkt"
  526.       ENDIF
  527.       GOSUB gummikasten
  528.       GRAPHMODE 1
  529.       DEFLINE 1,breite,2,2
  530.       DEFFILL 1,muster1,muster2
  531.       IF figurfuellen!
  532.         PBOX x%,y%,x1%,y1%
  533.       ELSE
  534.         BOX x%,y%,x1%,y1%
  535.       ENDIF
  536.       PAUSE 5
  537.     ENDIF
  538.   LOOP
  539.   GET 271,201,519,349,bild$(bild%)
  540.   TEXT 270,195,SPACE$(45)
  541.   GOSUB reparatur
  542.   REPEAT
  543.   UNTIL MOUSEK=0
  544. RETURN
  545. '
  546. PROCEDURE gummikasten
  547.   DEFLINE 1,1,0,0
  548.   REPEAT
  549.     MOUSE x%,y%,k%
  550.   UNTIL k% AND x%>20 AND x%<520 AND y%>200 AND y%<350
  551.   GRAPHMODE 3
  552.   PAUSE 10
  553.   REPEAT
  554.     MOUSE x1%,y1%,k%
  555.     IF x1%<20
  556.       x1%=20
  557.     ENDIF
  558.     IF x1%>520
  559.       x1%=520
  560.     ENDIF
  561.     IF y1%>350
  562.       y1%=350
  563.     ENDIF
  564.     IF y1%<200
  565.       y1%=200
  566.     ENDIF
  567.     BOX x%,y%,x1%,y1%
  568.     PAUSE 2
  569.     BOX x%,y%,x1%,y1%
  570.   UNTIL k%<>1
  571.   IF x1%<x%
  572.     SWAP x1%,x%
  573.   ENDIF
  574.   IF y1%<y%
  575.     SWAP y1%,y%
  576.   ENDIF
  577. RETURN
  578. '
  579. PROCEDURE kasten_schwarz(z)
  580.   IF z>6
  581.     y%=110
  582.     SUB z,6
  583.   ELSE
  584.     y%=50
  585.   ENDIF
  586.   x%=100*z-80
  587.   GRAPHMODE 3
  588.   DEFFILL 1,2,8
  589.   PBOX x%,y%,x%+100,y%+60
  590.   GRAPHMODE 1
  591. RETURN
  592. '
  593. PROCEDURE merken
  594.   GET 271,201,519,349,merk$
  595.   merk%=bild%
  596.   text$=" Bild "+STR$(bild%)+" gemerkt          "
  597.   TEXT 430,195,text$
  598.   block_gemerkt!=FALSE
  599. RETURN
  600. '
  601. PROCEDURE einsetzen
  602.   IF merk$=""
  603.     ALERT 0,"Es ist kein Bild gemerkt!",1,"ach so",antw
  604.   ELSE
  605.     IF block_gemerkt!
  606.       GOSUB b_einsetzen
  607.     ELSE
  608.       GET 271,201,519,349,bild$(bild%)      ! zum Untersuchen, ob Bild leer ist
  609.       REPEAT
  610.       UNTIL MOUSEK=0
  611.       IF bild$(bild%)<>bild$(0) AND k%=2
  612.         PUT 271,201,merk$
  613.       ENDIF
  614.       IF bild$(bild%)=bild$(0)
  615.         PUT 271,201,merk$
  616.       ENDIF
  617.     ENDIF
  618.   ENDIF
  619.   GET 271,201,519,349,bild$(bild%)
  620. RETURN
  621. '
  622. PROCEDURE zurueck
  623.   IF bild%>1
  624.     GET 271,201,519,349,bild$(bild%)
  625.     DEC bild%
  626.   ENDIF
  627.   '
  628.   GOSUB reparatur
  629.   '
  630.   PAUSE 5
  631. RETURN
  632. '
  633. PROCEDURE vor
  634.   GET 271,201,519,349,bild$(bild%)
  635.   IF bild%<schluss AND bild$(bild%)<>bild$(0)
  636.     INC bild%                     ! Bild weiterzählen
  637.     IF bild$(bild%)=""            ! falls neues Bild nichts enthält:
  638.       INC endbild%                ! Endbildnummer erhöhen
  639.       bild$(bild%)=bild$(0)       ! Leerbild auf neues Bild
  640.       IF bild%=schluss
  641.         REPEAT
  642.         UNTIL MOUSEK=0
  643.         ALERT 0,"Das ist das letzte Bild",1," na ja ",antw
  644.       ENDIF
  645.     ENDIF
  646.     '
  647.     GOSUB reparatur
  648.     '
  649.   ENDIF
  650.   PAUSE 5
  651. RETURN
  652. '
  653. PROCEDURE loeschen
  654.   IF k%=2
  655.     bild$(bild%)=bild$(0)
  656.     PUT 271,201,bild$(0)
  657.   ENDIF
  658. RETURN
  659. '
  660. PROCEDURE entfernen                       ! hier wird ein Bild ganz gelöscht,
  661.   IF k%=2                                 ! indem die folgenden Bilder
  662.     FOR i%=bild% TO endbild%              ! um ein Bild vorrücken
  663.       bild$(i%)=bild$(i%+1)
  664.     NEXT i%
  665.     IF endbild%=bild% AND bild%>1
  666.       DEC bild%
  667.     ENDIF
  668.     IF endbild%>1
  669.       DEC endbild%
  670.     ENDIF
  671.     REPEAT
  672.     UNTIL MOUSEK=0
  673.     GOSUB reparatur
  674.   ENDIF
  675. RETURN
  676. '
  677. PROCEDURE erweitern                ! hier wird ein leeres Bild zwischengefügt
  678.   IF bild$(bild%)<>bild$(0)        ! indem die folgenden Bilder um ein Bild
  679.     INC endbild%                   ! nach hinten rücken
  680.     FOR i%=endbild% DOWNTO bild%
  681.       bild$(i%)=bild$(i%-1)
  682.     NEXT i%
  683.     IF endbild%>schluss
  684.       bild$(endbild%)=""
  685.       DEC endbild%
  686.     ENDIF
  687.     bild$(bild%)=bild$(0)
  688.     GOSUB reparatur
  689.   ENDIF
  690. RETURN
  691. '
  692. PROCEDURE alles_weg
  693.   ALERT 0,"Den ganzen Film löschen? ",2,"  ja  | nein ",antw
  694.   IF antw=1
  695.     FOR i%=1 TO schluss
  696.       bild$(i%)=""
  697.     NEXT i%
  698.     bild$(1)=bild$(0)
  699.     bild%=1
  700.     endbild%=1
  701.     PUT 21,201,bild$(0)
  702.     PUT 271,201,bild$(1)
  703.     TEXT 270,195," Bild "+STR$(bild%)+" (von "+STR$(endbild%)+")   "
  704.   ENDIF
  705. RETURN
  706. '
  707. '
  708. FOR i%=200 TO 360 STEP 20                      ! Kästen rechts neben Bildern
  709.   BOX 540,i%,620,i%+20
  710. NEXT i%
  711. '
  712. PROCEDURE zu_bild                    ! zu eingegebenem Bild gehen
  713.   GET 271,201,519,349,bild$(bild%)
  714.   DEFFILL 1,2,1
  715.   PBOX 540,360,635,390
  716.   HIDEM
  717.   PRINT AT(69,24);"zu Bild:";
  718.   FORM INPUT 3,i$
  719.   bild%=VAL(i$)
  720.   IF bild%>endbild%
  721.     bild%=endbild%
  722.   ENDIF
  723.   IF bild%<1
  724.     bild%=1
  725.   ENDIF
  726.   SHOWM
  727.   GOSUB reparatur
  728. RETURN
  729. '
  730. PROCEDURE kopieren
  731.   IF NOT block!
  732.     GET 271,201,519,349,bild$(bild%)
  733.     antw=0
  734.     IF (bild$(bild%)<>bild$(0) AND k%=2) OR (bild$(bild%)=bild$(0))
  735.       PUT 271,201,bild$(bild%-1)
  736.     ENDIF
  737.   ENDIF
  738. RETURN
  739. '
  740. PROCEDURE hoch
  741.   IF k%=1
  742.     GET 271,202,519,349,schieb$
  743.   ELSE
  744.     GET 271,206,519,349,schieb$
  745.   ENDIF
  746.   PUT 271,201,bild$(0)
  747.   PUT 271,201,schieb$
  748. RETURN
  749. '
  750. PROCEDURE runter
  751.   IF k%=1
  752.     GET 271,201,519,348,schieb$
  753.   ELSE
  754.     GET 271,201,519,344,schieb$
  755.   ENDIF
  756.   PUT 271,201,bild$(0)
  757.   PUT 271,202-4*(k%>1),schieb$
  758. RETURN
  759. '
  760. PROCEDURE rechts
  761.   IF k%=1
  762.     GET 271,201,518,349,schieb$
  763.   ELSE
  764.     GET 271,201,514,349,schieb$
  765.   ENDIF
  766.   PUT 271,201,bild$(0)
  767.   PUT 272-4*(k%>1),201,schieb$
  768. RETURN
  769. '
  770. PROCEDURE links
  771.   IF k%=1
  772.     GET 272,201,519,349,schieb$
  773.   ELSE
  774.     GET 276,201,519,349,schieb$
  775.   ENDIF
  776.   PUT 271,201,bild$(0)
  777.   PUT 271,201,schieb$
  778. RETURN
  779. '
  780. PROCEDURE speicher_einrichten
  781.   schluss=100                       ! letzter Bildspeicher
  782.   DIM bild$(schluss+1)              ! Bildspeicher
  783.   bild%=1                           ! Nummer des bearbeiteten Bildes
  784.   endbild%=1                        ! höchste Bildnummer
  785.   '
  786.   breite=1                          ! Strichstärke
  787.   muster1=2                         ! Angaben für DEFFILL
  788.   muster2=4                         !     "    "    "
  789.   block!=FALSE                      ! Flag zur Markierung, ob Blockoperation
  790.   '
  791.   DEFFILL 1,muster1,muster2         ! vorgegebenes Füllmuster: grau
  792. RETURN
  793. '
  794. PROCEDURE titelbild
  795.   '
  796.   DEFTEXT 1,16,0,32
  797.   TEXT 20,40,"# Zeichentrickfilmprogramm #######"
  798.   DEFTEXT 1,0,0,13
  799.   '
  800.   BOX 20,200,270,350                               ! Kästen für Filmbilder
  801.   BOX 270,200,520,350
  802.   GET 21,201,269,349,bild$(0)                      ! leeres Bild
  803.   bild$(1)=bild$(0)
  804.   '
  805.   TEXT 25,75,"   Film         Film        Film      Füllmuster  Liniendicke    Figuren   "
  806.   TEXT 25,95," speichern      laden     abspielen   auswählen      (1)       ausfüllen"
  807.   TEXT 25,135," ausfüllen     Block        Kreis      Ellipse      Gerade       Kasten"
  808.   '
  809.   FOR i%=20 TO 520 STEP 100                      ! obere Kastenreihe
  810.     BOX i%,50,i%+100,110
  811.   NEXT i%
  812.   '
  813.   FOR i%=20 TO 520 STEP 100                      ! zweite Kastenreihe
  814.     BOX i%,110,i%+100,170
  815.   NEXT i%
  816.   '
  817.   FOR i%=200 TO 360 STEP 20                      ! Kästen rechts neben Bildern
  818.     BOX 540,i%,620,i%+20
  819.   NEXT i%
  820.   '
  821.   TEXT 545,215,"rückwärts"
  822.   TEXT 545,235,"vorwärts"
  823.   TEXT 545,255,"merken"
  824.   TEXT 545,275,"einsetzen"
  825.   TEXT 545,295,"löschen"
  826.   TEXT 545,315,"entfernen"
  827.   TEXT 545,335,"erweitern"
  828.   TEXT 545,355,"alles weg"
  829.   TEXT 545,375,"zu Bild.."
  830.   '
  831.   BOX 20,360,130,380                            ! Kasten unten links
  832.   TEXT 25,375,"Programmende"
  833.   '
  834.   TEXT 278,375,"⇧  ⇩  ⇨  ⇦         ⇨"
  835.   FOR i%=270 TO 350 STEP 24                      ! Kästen unter rechtem Bild
  836.     BOX i%,360,i%+24,380
  837.   NEXT i%
  838.   '
  839.   BOX 405,360,460,380
  840.   BOX 410,365,425,375
  841.   BOX 440,365,455,375
  842.   '
  843.   SGET titelbild$
  844.   TEXT 270,195," Bild "+STR$(bild%)+" (von "+STR$(endbild%)+") "
  845.   PBOX 20,140,120,170
  846.   '
  847. RETURN
  848. '
  849. PROCEDURE ende
  850.   ALERT 2,"   Soll das Programm   | wirklich beendet werden?",2,"  ja  | nein ",antw
  851.   IF antw=1
  852.     EDIT                                        ! später SYSTEM einsetzen
  853.   ENDIF
  854. RETURN
  855. '
  856. PROCEDURE reparatur                             ! Bild reparieren, falls
  857.   SPUT titelbild$                               ! das neue Bild den Rand
  858.   TEXT 449,95,"("+STR$(breite)+")  "            ! zerstört hat.
  859.   TEXT 430,195,text$
  860.   PUT 21,201,bild$(bild%-1)
  861.   PUT 271,201,bild$(bild%)
  862.   TEXT 270,195," Bild "+STR$(bild%)+" (von "+STR$(endbild%)+")    "
  863.   TEXT 430,195,text$
  864.   DEFFILL 1,muster1,muster2
  865.   PBOX 20,140,120,170
  866.   DEFMOUSE 0
  867.   DEFLINE 1,breite,2,2
  868.   figurfuellen!=FALSE
  869. RETURN
  870. '
  871. PROCEDURE b_hoch
  872.   SUB b1%,b
  873.   SUB b2%,b
  874.   IF b2%<200
  875.     ADD b1%,b
  876.     ADD b2%,b
  877.   ENDIF
  878. RETURN
  879. '
  880. PROCEDURE b_runter
  881.   ADD b1%,b
  882.   ADD b2%,b
  883.   IF b1%>350
  884.     SUB b1%,b
  885.     SUB b2%,b
  886.   ENDIF
  887. RETURN
  888. '
  889. PROCEDURE b_rechts
  890.   ADD a1%,b
  891.   ADD a2%,b
  892.   IF a1%>520
  893.     SUB a1%,b
  894.     SUB a2%,b
  895.   ENDIF
  896. RETURN
  897. '
  898. PROCEDURE b_links
  899.   SUB a1%,b
  900.   SUB a2%,b
  901.   IF a2%<270
  902.     ADD a1%,b
  903.     ADD a2%,b
  904.   ENDIF
  905. RETURN
  906. '
  907. PROCEDURE b_merken
  908.   GRAPHMODE 3
  909.   BOX a1%,b1%,a2%,b2%
  910.   GET a1%,b1%,a2%,b2%,merk$
  911.   '
  912.   DEFFILL 1,2,8                         ! gemerkten Block kurz invertieren
  913.   PBOX a1%,b1%,a2%,b2%
  914.   PAUSE 20
  915.   PBOX a1%,b1%,a2%,b2%
  916.   DEFFILL 1,muster1,muster2
  917.   '
  918.   BOX a1%,b1%,a2%,b2%
  919.   GRAPHMODE 1
  920.   block_gemerkt!=TRUE
  921.   text$="Block aus Bild "+STR$(bild%)+" gemerkt"
  922.   TEXT 430,195,text$
  923.   ' GOSUB block
  924.   REPEAT
  925.   UNTIL MOUSEK=0
  926. RETURN
  927. '
  928. ' Die folgende Procedure stammt aus dem Buch "GFA BASIC" von F. Ostrowski
  929. '
  930. PROCEDURE b_einsetzen
  931.   DIM bild%(32255/4)
  932.   a%=XBIOS(3)
  933.   b%=(VARPTR(bild%(0))+255) AND &HFFFF00
  934.   SGET bildschirm$
  935.   REPEAT
  936.     SWAP a%,b%
  937.     VOID XBIOS(5,L:a%,L:b%,-1)
  938.     SPUT bildschirm$
  939.     MOUSE x%,y%,k%
  940.     PUT x%,y%,merk$
  941.     IF k%=1                       ! Block kann beliebig eingesetzt werden.
  942.       SGET bildschirm$            ! egal, ob Bildschirmrest überdeckt wird,
  943.     ENDIF                         ! da Reparatur erfolgt
  944.   UNTIL k%=2
  945.   a%=MAX(a%,b%)
  946.   VOID XBIOS(5,L:a%,L:a%,-1)
  947.   SPUT bildschirm$
  948.   GET 271,201,519,349,bild$(bild%)
  949.   ERASE bild%()
  950.   GOSUB reparatur
  951. RETURN
  952. '
  953. PROCEDURE b_loeschen
  954.   IF k%=2
  955.     DEFFILL 0,2,8
  956.     PBOX a1%+1,b1%+1,a2%-1,b2%-1
  957.     DEFFILL 1,muster1,muster2
  958.     z=8
  959.     GOSUB block
  960.   ENDIF
  961. RETURN
  962.